home *** CD-ROM | disk | FTP | other *** search
/ Complete Internet Archive / Complete Internet Archive.iso / VRML / cp2b2x.exe / DATA.Z / prolog.ps < prev    next >
Text File  |  1996-04-23  |  10KB  |  287 lines
  1. %%BeginProlog
  2. 50 dict begin
  3.  
  4. % This is a standard prolog for Postscript generated by Tk's canvas
  5. % widget.
  6. % @(#) prolog.ps 1.2 94/12/09 10:53:18
  7.  
  8. % The definitions below just define all of the variables used in
  9. % any of the procedures here.  This is needed for obscure reasons
  10. % explained on p. 716 of the Postscript manual (Section H.2.7,
  11. % "Initializing Variables," in the section on Encapsulated Postscript).
  12.  
  13. /baseline 0 def
  14. /stipimage 0 def
  15. /height 0 def
  16. /justify 0 def
  17. /lineLength 0 def
  18. /spacing 0 def
  19. /stipple 0 def
  20. /strings 0 def
  21. /xoffset 0 def
  22. /yoffset 0 def
  23. /tmpstip null def
  24.  
  25. % Define the array ISOLatin1Encoding (which specifies how characters are
  26. % encoded for ISO-8859-1 fonts), if it isn't already present (Postscript
  27. % level 2 is supposed to define it, but level 1 doesn't).
  28.  
  29. systemdict /ISOLatin1Encoding known not {
  30.     /ISOLatin1Encoding [
  31.     /space /space /space /space /space /space /space /space
  32.     /space /space /space /space /space /space /space /space
  33.     /space /space /space /space /space /space /space /space
  34.     /space /space /space /space /space /space /space /space
  35.     /space /exclam /quotedbl /numbersign /dollar /percent /ampersand
  36.         /quoteright
  37.     /parenleft /parenright /asterisk /plus /comma /minus /period /slash
  38.     /zero /one /two /three /four /five /six /seven
  39.     /eight /nine /colon /semicolon /less /equal /greater /question
  40.     /at /A /B /C /D /E /F /G
  41.     /H /I /J /K /L /M /N /O
  42.     /P /Q /R /S /T /U /V /W
  43.     /X /Y /Z /bracketleft /backslash /bracketright /asciicircum /underscore
  44.     /quoteleft /a /b /c /d /e /f /g
  45.     /h /i /j /k /l /m /n /o
  46.     /p /q /r /s /t /u /v /w
  47.     /x /y /z /braceleft /bar /braceright /asciitilde /space
  48.     /space /space /space /space /space /space /space /space
  49.     /space /space /space /space /space /space /space /space
  50.     /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent
  51.     /dieresis /space /ring /cedilla /space /hungarumlaut /ogonek /caron
  52.     /space /exclamdown /cent /sterling /currency /yen /brokenbar /section
  53.     /dieresis /copyright /ordfeminine /guillemotleft /logicalnot /hyphen
  54.         /registered /macron
  55.     /degree /plusminus /twosuperior /threesuperior /acute /mu /paragraph
  56.         /periodcentered
  57.     /cedillar /onesuperior /ordmasculine /guillemotright /onequarter
  58.         /onehalf /threequarters /questiondown
  59.     /Agrave /Aacute /Acircumflex /Atilde /Adieresis /Aring /AE /Ccedilla
  60.     /Egrave /Eacute /Ecircumflex /Edieresis /Igrave /Iacute /Icircumflex
  61.         /Idieresis
  62.     /Eth /Ntilde /Ograve /Oacute /Ocircumflex /Otilde /Odieresis /multiply
  63.     /Oslash /Ugrave /Uacute /Ucircumflex /Udieresis /Yacute /Thorn
  64.         /germandbls
  65.     /agrave /aacute /acircumflex /atilde /adieresis /aring /ae /ccedilla
  66.     /egrave /eacute /ecircumflex /edieresis /igrave /iacute /icircumflex
  67.         /idieresis
  68.     /eth /ntilde /ograve /oacute /ocircumflex /otilde /odieresis /divide
  69.     /oslash /ugrave /uacute /ucircumflex /udieresis /yacute /thorn
  70.         /ydieresis
  71.     ] def
  72. } if
  73.  
  74. % Override the setfont procedure with a new procedure that re-encodes
  75. % the font to use the ISO Latin-1 style.  The body of this procedure
  76. % comes from Section 5.6.1 of the Postscript book.
  77.  
  78. /realsetfont /setfont load def
  79. /setfont {
  80.     dup length dict begin
  81.     {1 index /FID ne {def} {pop pop} ifelse} forall
  82.     /Encoding ISOLatin1Encoding def
  83.     currentdict
  84.     end
  85.  
  86.     % I'm not sure why it's necessary to use "definefont" on this new
  87.     % font, but it seems to be important; just use the name "Temporary"
  88.     % for the font.
  89.  
  90.     /Temporary exch definefont
  91.     realsetfont
  92. } bind def
  93.  
  94. % StrokeClip
  95. %
  96. % This procedure converts the current path into a clip area under
  97. % the assumption of stroking.  It's a bit tricky because some Postscript
  98. % interpreters get errors during strokepath for dashed lines.  If
  99. % this happens then turn off dashes and try again.
  100.  
  101. /StrokeClip {
  102.     {strokepath} stopped {
  103.     (This Postscript printer gets limitcheck overflows when) =
  104.     (stippling dashed lines;  lines will be printed solid instead.) =
  105.     [] 0 setdash strokepath} if
  106.     clip
  107. } bind def
  108.  
  109. % desiredSize EvenPixels closestSize
  110. %
  111. % The procedure below is used for stippling.  Given the optimal size
  112. % of a dot in a stipple pattern in the current user coordinate system,
  113. % compute the closest size that is an exact multiple of the device's
  114. % pixel size.  This allows stipple patterns to be displayed without
  115. % aliasing effects.
  116.  
  117. /EvenPixels {
  118.     % Compute exact number of device pixels per stipple dot.
  119.     dup 0 matrix currentmatrix dtransform
  120.     dup mul exch dup mul add sqrt
  121.  
  122.     % Round to an integer, make sure the number is at least 1, and compute
  123.     % user coord distance corresponding to this.
  124.     dup round dup 1 lt {pop 1} if
  125.     exch div mul
  126. } bind def
  127.  
  128. % width height string StippleFill --
  129. %
  130. % Given a path already set up and a clipping region generated from
  131. % it, this procedure will fill the clipping region with a stipple
  132. % pattern.  "String" contains a proper image description of the
  133. % stipple pattern and "width" and "height" give its dimensions.  Each
  134. % stipple dot is assumed to be about one unit across in the current
  135. % user coordinate system.  This procedure trashes the graphics state.
  136.  
  137. /StippleFill {
  138.     % The following code is needed to work around a NeWSprint bug.
  139.  
  140.     /tmpstip 1 index def
  141.  
  142.     % Change the scaling so that one user unit in user coordinates
  143.     % corresponds to the size of one stipple dot.
  144.     1 EvenPixels dup scale
  145.  
  146.     % Compute the bounding box occupied by the path (which is now
  147.     % the clipping region), and round the lower coordinates down
  148.     % to the nearest starting point for the stipple pattern.  Be
  149.     % careful about negative numbers, since the rounding works
  150.     % differently on them.
  151.  
  152.     pathbbox
  153.     4 2 roll
  154.     5 index div dup 0 lt {1 sub} if cvi 5 index mul 4 1 roll
  155.     6 index div dup 0 lt {1 sub} if cvi 6 index mul 3 2 roll
  156.  
  157.     % Stack now: width height string y1 y2 x1 x2
  158.     % Below is a doubly-nested for loop to iterate across this area
  159.     % in units of the stipple pattern size, going up columns then
  160.     % across rows, blasting out a stipple-pattern-sized rectangle at
  161.     % each position
  162.  
  163.     6 index exch {
  164.     2 index 5 index 3 index {
  165.         % Stack now: width height string y1 y2 x y
  166.  
  167.         gsave
  168.         1 index exch translate
  169.         5 index 5 index true matrix tmpstip imagemask
  170.         grestore
  171.     } for
  172.     pop
  173.     } for
  174.     pop pop pop pop pop
  175. } bind def
  176.  
  177. % -- AdjustColor --
  178. % Given a color value already set for output by the caller, adjusts
  179. % that value to a grayscale or mono value if requested by the CL
  180. % variable.
  181.  
  182. /AdjustColor {
  183.     CL 2 lt {
  184.     currentgray
  185.     CL 0 eq {
  186.         .5 lt {0} {1} ifelse
  187.     } if
  188.     setgray
  189.     } if
  190. } bind def
  191.  
  192. % x y strings lineLength spacing xoffset yoffset justify stipple DrawText --
  193. % This procedure does all of the real work of drawing text.  The
  194. % color and font must already have been set by the caller, and the
  195. % following arguments must be on the stack:
  196. %
  197. % x, y -    Coordinates at which to draw text.
  198. % strings -    An array of strings, one for each line of the text item,
  199. %        in order from top to bottom.
  200. % lineLength -    Minimum line length:  needed to justify text properly.
  201. % spacing -    Spacing between lines.
  202. % xoffset -    Horizontal offset for text bbox relative to x and y: 0 for
  203. %        nw/w/sw anchor, -0.5 for n/center/s, and -1.0 for ne/e/se.
  204. % yoffset -    Vertical offset for text bbox relative to x and y: 0 for
  205. %        nw/n/ne anchor, +0.5 for w/center/e, and +1.0 for sw/s/se.
  206. % justify -    0 for left justification, 0.5 for center, 1 for right justify.
  207. % stipple -    Boolean value indicating whether or not text is to be
  208. %        drawn in stippled fashion.  If text is stippled,
  209. %        procedure StippleText must have been defined to call
  210. %        StippleFill in the right way.
  211. %
  212. % Also, when this procedure is invoked, the color and font must already
  213. % have been set for the text.
  214.  
  215. /DrawText {
  216.     /stipple exch def
  217.     /justify exch def
  218.     /yoffset exch def
  219.     /xoffset exch def
  220.     /spacing exch def
  221.     /lineLength exch def
  222.     /strings exch def
  223.  
  224.     % First scan through all of the text to find the widest line (if it's
  225.     % longer than the "lineLength" argument).
  226.  
  227.     strings {
  228.     stringwidth pop
  229.     dup lineLength gt {/lineLength exch def} {pop} ifelse
  230.     newpath
  231.     } forall
  232.  
  233.     % Compute the baseline offset and the actual font height.
  234.  
  235.     0 0 moveto (TXygqPZ) false charpath
  236.     pathbbox dup /baseline exch def
  237.     exch pop exch sub /height exch def pop
  238.     newpath
  239.  
  240.     % Translate coordinates first so that the origin is at the upper-left
  241.     % corner of the text's bounding box. Remember that x and y for
  242.     % positioning are still on the stack.
  243.  
  244.     translate
  245.     lineLength xoffset mul
  246.     strings length 1 sub spacing mul height add yoffset mul translate
  247.  
  248.     % Now use the baseline and justification information to translate so
  249.     % that the origin is at the baseline and positioning point for the
  250.     % first line of text.
  251.  
  252.     justify lineLength mul baseline neg translate
  253.  
  254.     % Iterate over each of the lines to output it.  For each line,
  255.     % compute its width again so it can be properly justified, then
  256.     % display it.
  257.  
  258.     strings {
  259.     dup stringwidth pop
  260.     justify neg mul 0 moveto
  261.     stipple {
  262.  
  263.         % The text is stippled, so turn it into a path and print
  264.         % by calling StippledText, which in turn calls StippleFill.
  265.         % Unfortunately, many Postscript interpreters will get
  266.         % overflow errors if we try to do the whole string at
  267.         % once, so do it a character at a time.
  268.  
  269.         gsave
  270.         /char (X) def
  271.         {
  272.         char 0 3 -1 roll put
  273.         currentpoint
  274.         gsave
  275.         char true charpath clip StippleText
  276.         grestore
  277.         char stringwidth translate
  278.         moveto
  279.         } forall
  280.         grestore
  281.     } {show} ifelse
  282.     0 spacing neg translate
  283.     } forall
  284. } bind def
  285.  
  286. %%EndProlog
  287.